home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / XLISP / XLISP21S / sources / c / xlobj < prev    next >
Text File  |  1992-04-25  |  17KB  |  629 lines
  1. /* xlobj - xlisp object functions */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv,xldenv,xlvalue;
  10. extern LVAL s_stdout,s_lambda;
  11.  
  12. /* local variables (jsp: nonstatic because used externally by some apps) */
  13. LVAL s_self=0,k_new=0,k_isnew=0;
  14. LVAL k_prin1;
  15. LVAL cls_class=0,cls_object=0;
  16.  
  17. /* instance variable numbers for the class 'Class' */
  18. #define MESSAGES        0       /* list of messages */
  19. #define IVARS           1       /* list of instance variable names */
  20. #define CVARS           2       /* list of class variable names */
  21. #define CVALS           3       /* list of class variable values */
  22. #define SUPERCLASS      4       /* pointer to the superclass */
  23. #define IVARCNT         5       /* number of class instance variables */
  24. #define IVARTOTAL       6       /* total number of instance variables */
  25. #define PNAME           7       /* print name TAA Mod */
  26. /* number of instance variables for the class 'Class' */
  27. #define CLASSSIZE       8
  28.  
  29. /* forward declarations */
  30. #ifdef ANSI
  31. LVAL NEAR entermsg(LVAL cls, LVAL msg);
  32. LVAL NEAR sendmsg(LVAL obj, LVAL cls, LVAL sym);
  33. LVAL NEAR evmethod(LVAL obj, LVAL msgcls, LVAL method);
  34. int  NEAR getivcnt(LVAL cls, int ivar);
  35. int  NEAR listlength(LVAL list);
  36. #else
  37. FORWARD LVAL entermsg();
  38. FORWARD LVAL sendmsg();
  39. FORWARD LVAL evmethod();
  40. #endif
  41.  
  42. /* $putpatch.c$: "MODULE_XLOBJ_C_GLOBALS" */
  43.  
  44. /* routine to print an object for PRINx */
  45. #ifdef ANSI
  46. static VOID NEAR xputobj(LVAL fptr, LVAL val)
  47. #else
  48. LOCAL VOID xputobj(fptr,val)
  49.   LVAL fptr; LVAL val;
  50. #endif
  51. {
  52.     LVAL temp;
  53.     if ((temp = getclass(val)) == cls_class) { /* this is a class */
  54.         if (null(temp = getivar(val,PNAME)) || (ntype(temp) != STRING) ) { 
  55.             /* but nameless */
  56.             xlputstr(fptr,"#<class ???: #");
  57.         }
  58.         else {
  59. #ifdef MEDMEM
  60.             strcpy(buf, "#<class ");
  61.             STRCAT(buf, getstring(temp));
  62.             strcat(buf, ": #");
  63. #else
  64.             sprintf(buf,"#<class %s: #",getstring(temp));
  65. #endif
  66.             xlputstr(fptr,buf);
  67.         }
  68.     }
  69.     else { /* not a class */
  70.         if (null(temp = getivar(temp,PNAME)) || (ntype(temp) != STRING) ) {
  71.             /* but nameless */
  72.             xlputstr(fptr,"#<a ??? object: #");
  73.         }
  74.         else {
  75. #ifdef MEDMEM
  76.             strcpy(buf, "#<a ");
  77.             STRCAT(buf, getstring(temp));
  78.             strcat(buf, ": #");
  79. #else
  80.             sprintf(buf,"#<a %s: #",getstring(temp));
  81. #endif
  82.             xlputstr(fptr,buf);
  83.         }
  84.     }
  85.     sprintf(buf,AFMT,val); 
  86.     xlputstr(fptr,buf);
  87.     xlputc(fptr,'>');
  88. }
  89.                 
  90.  
  91. /* xsend - send a message to an object */
  92. LVAL xsend()
  93. {
  94.     LVAL obj;
  95.     obj = xlgaobject();
  96.     return (sendmsg(obj,getclass(obj),xlgasymbol()));
  97. }
  98.  
  99. /* xsendsuper - send a message to the superclass of an object */
  100. LVAL xsendsuper()
  101. {
  102.     LVAL env,p;
  103.     for (env = xlenv; !null(env); env = cdr(env))
  104.         if ((!null(p = car(env))) && objectp(car(p)))
  105.             return (sendmsg(car(p),
  106.                             getivar(cdr(p),SUPERCLASS),
  107.                             xlgasymbol()));
  108.     xlfail("not in a method");
  109.     return (NIL);   /* fake out compiler warning */
  110. }
  111.  
  112. /* xlclass - define a class */
  113. #ifdef ANSI
  114. static LVAL NEAR xlclass(char *name, int vcnt)
  115. #else
  116. LOCAL LVAL xlclass(name,vcnt)
  117.   char *name; int vcnt;
  118. #endif
  119. {
  120.     LVAL sym,cls;
  121.  
  122.     /* create the class */
  123.     sym = xlenter(name);
  124.     cls = newobject(cls_class,CLASSSIZE);
  125.     defconstant(sym,cls);   /* TAA MOD -- was setvalue */
  126.  
  127.     /* set the instance variable counts */
  128.     setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt));
  129.     setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt));
  130.  
  131.     /* set the class name   TAA Mod */
  132.     setivar(cls,PNAME,cvstring(name));
  133.  
  134.     /* set the superclass to 'Object' */
  135.     setivar(cls,SUPERCLASS,cls_object);
  136.  
  137.     /* return the new class */
  138.     return (cls);
  139. }
  140.  
  141. /* xladdivar - enter an instance variable */
  142. #ifdef ANSI
  143. static VOID NEAR xladdivar(LVAL cls, char *var)
  144. #else
  145. LOCAL VOID xladdivar(cls,var)
  146.   LVAL cls; char *var;
  147. #endif
  148. {
  149.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  150. }
  151.  
  152. /* xladdmsg - add a message to a class */
  153. #ifdef ANSI
  154. static VOID NEAR xladdmsg(LVAL cls, char *msg, int offset)
  155. #else
  156. LOCAL VOID xladdmsg(cls,msg,offset)
  157.   LVAL cls; char *msg; int offset;
  158. #endif
  159. {
  160.     extern FUNDEF funtab[];
  161.     LVAL mptr;
  162.  
  163.     /* enter the message selector */
  164.     mptr = entermsg(cls,xlenter(msg));
  165.  
  166.     /* store the method for this message */
  167.     rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
  168. }
  169.  
  170. /* xlobgetvalue - get the value of an instance variable */
  171. int xlobgetvalue(pair,sym,pval)
  172.   LVAL pair,sym,*pval;
  173. {
  174.     LVAL cls,names;
  175.     int ivtotal,n;
  176.  
  177.     /* find the instance or class variable */
  178.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  179.  
  180.         /* check the instance variables */
  181.         names = getivar(cls,IVARS);
  182.         ivtotal = getivcnt(cls,IVARTOTAL);
  183.         for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  184.             if (car(names) == sym) {
  185.                 *pval = getivar(car(pair),n);
  186.                 return (TRUE);
  187.             }
  188.             names = cdr(names);
  189.         }
  190.  
  191.         /* check the class variables */
  192.         names = getivar(cls,CVARS);
  193.         for (n = 0; consp(names); ++n) {
  194.             if (car(names) == sym) {
  195.                 *pval = getelement(getivar(cls,CVALS),n);
  196.                 return (TRUE);
  197.             }
  198.             names = cdr(names);
  199.         }
  200.     }
  201.  
  202.     /* variable not found */
  203.     return (FALSE);
  204. }
  205.  
  206. /* xlobsetvalue - set the value of an instance variable */
  207. int xlobsetvalue(pair,sym,val)
  208.   LVAL pair,sym,val;
  209. {
  210.     LVAL cls,names;
  211.     int ivtotal,n;
  212.  
  213.     /* find the instance or class variable */
  214.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  215.  
  216.         /* check the instance variables */
  217.         names = getivar(cls,IVARS);
  218.         ivtotal = getivcnt(cls,IVARTOTAL);
  219.         for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  220.             if (car(names) == sym) {
  221.                 setivar(car(pair),n,val);
  222.                 return (TRUE);
  223.             }
  224.             names = cdr(names);
  225.         }
  226.  
  227.         /* check the class variables */
  228.         names = getivar(cls,CVARS);
  229.         for (n = 0; consp(names); ++n) {
  230.             if (car(names) == sym) {
  231.                 setelement(getivar(cls,CVALS),n,val);
  232.                 return (TRUE);
  233.             }
  234.             names = cdr(names);
  235.         }
  236.     }
  237.  
  238.     /* variable not found */
  239.     return (FALSE);
  240. }
  241.  
  242. /* obisnew - default 'isnew' method */
  243. LVAL obisnew()
  244. {
  245.     LVAL self;
  246.     self = xlgaobject();
  247.     xllastarg();
  248.     return (self);
  249. }
  250.  
  251. /* obclass - get the class of an object */
  252. LVAL obclass()
  253. {
  254.     LVAL self;
  255.     self = xlgaobject();
  256.     xllastarg();
  257.     return (getclass(self));
  258. }
  259.  
  260. /* obshow - show the instance variables of an object */
  261. LVAL obshow()
  262. {
  263.     LVAL self,fptr,cls,names;
  264.     int ivtotal,n;
  265.  
  266.     /* get self and the file pointer */
  267.     self = xlgaobject();
  268.     fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
  269.     xllastarg();
  270.  
  271.     /* get the object's class */
  272.     cls = getclass(self);
  273.  
  274.     /* print the object and class */
  275.     xlputstr(fptr,"Object is ");
  276.     xlprint(fptr,self,TRUE);
  277.     xlputstr(fptr,", Class is ");
  278.     xlprint(fptr,cls,TRUE);
  279.     xlterpri(fptr);
  280.  
  281.     /* print the object's instance variables */
  282.     for (; !null(cls); cls = getivar(cls,SUPERCLASS)) {
  283.         names = getivar(cls,IVARS);
  284.         ivtotal = getivcnt(cls,IVARTOTAL);
  285.         for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  286.             xlputstr(fptr,"  ");
  287.             xlprint(fptr,car(names),TRUE);
  288.             xlputstr(fptr," = ");
  289.             xlprint(fptr,getivar(self,n),TRUE);
  290.             xlterpri(fptr);
  291.             names = cdr(names);
  292.         }
  293.     }
  294.  
  295.     /* return the object */
  296.     return (self);
  297. }
  298.  
  299. /* clnew - create a new object instance */
  300. LVAL clnew()
  301. {
  302.     LVAL self;
  303.     self = xlgaobject();
  304.     /* $putpatch.c$: "MODULE_XLOBJ_C_CLNEW" */
  305.     return (newobject(self,getivcnt(self,IVARTOTAL)));
  306. }
  307.  
  308. /* clisnew - initialize a new class */
  309. LVAL clisnew()
  310. {
  311.     LVAL self,ivars,cvars,super;
  312.     int n;
  313.  
  314.     /* get self, the ivars, cvars and superclass */
  315.     self = xlgaobject();
  316.     ivars = xlgalist();
  317.     cvars = (moreargs() ? xlgalist() : NIL);
  318.     super = (moreargs() ? xlgaobject() : cls_object);
  319.     xllastarg();
  320.  
  321.     /* store the instance and class variable lists and the superclass */
  322.     setivar(self,IVARS,ivars);
  323.     setivar(self,CVARS,cvars);
  324.     setivar(self,CVALS,(!null(cvars) ? newvector(listlength(cvars)) : NIL));
  325.     setivar(self,SUPERCLASS,super);
  326.  
  327.     /* compute the instance variable count */
  328.     n = listlength(ivars);
  329.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  330.     n += getivcnt(super,IVARTOTAL);
  331.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  332.  
  333.     /* return the new class object */
  334.     return (self);
  335. }
  336.  
  337. /* clanswer - define a method for answering a message */
  338. LVAL clanswer()
  339. {
  340.     LVAL self,msg,fargs,code,mptr;
  341.  
  342.     /* message symbol, formal argument list and code */
  343.     self = xlgaobject();
  344.     msg = xlgasymbol();
  345.     fargs = xlgalist();
  346.     code = xlgalist();
  347.     xllastarg();
  348.  
  349.     /* make a new message list entry */
  350.     mptr = entermsg(self,msg);
  351.  
  352.     /* setup the message node */
  353.     xlprot1(fargs);
  354.     fargs = cons(s_self,fargs); /* add 'self' as the first argument */
  355.         /* The following TAA MOD is by Neils Mayer, at HP */
  356.         /* it sets the lexical environment to be correct (non-global) */
  357. /*    rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL)); */
  358.     rplacd(mptr,xlclose(msg,s_lambda,fargs,code,xlenv,xlfenv));
  359.     xlpop();
  360.  
  361.     /* return the object */
  362.     return (self);
  363. }
  364.  
  365. /* entermsg - add a message to a class */
  366. LOCAL LVAL NEAR entermsg(cls,msg)
  367.   LVAL cls,msg;
  368. {
  369.     LVAL lptr,mptr;
  370.  
  371.     /* lookup the message */
  372.     for (lptr = getivar(cls,MESSAGES); !null(lptr); lptr = cdr(lptr))
  373.         if (car(mptr = car(lptr)) == msg)
  374.             return (mptr);
  375.  
  376.     /* allocate a new message entry if one wasn't found */
  377.     xlsave1(mptr);
  378.     mptr = consa(msg);
  379.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  380.     xlpop();
  381.  
  382.     /* return the symbol node */
  383.     return (mptr);
  384. }
  385.  
  386. /* sendmsg - send a message to an object */
  387. LOCAL LVAL NEAR sendmsg(obj,cls,sym)
  388.   LVAL obj,cls,sym;
  389. {
  390.     LVAL msg,msgcls,method,val,p;
  391.  
  392.     /* look for the message in the class or superclasses */
  393.     for (msgcls = cls; !null(msgcls); ) {
  394.  
  395.         /* lookup the message in this class */
  396.         for (p = getivar(msgcls,MESSAGES); !null(p); p = cdr(p))
  397.             if ((!null(msg = car(p))) && car(msg) == sym)
  398.                 goto send_message;
  399.  
  400.         /* look in class's superclass */
  401.         msgcls = getivar(msgcls,SUPERCLASS);
  402.     }
  403.  
  404.     /* message not found */
  405.     xlerror("no method for this message",sym);
  406.  
  407. send_message:
  408.  
  409.     /* insert the value for 'self' (overwrites message selector) */
  410.     *--xlargv = obj;
  411.     ++xlargc;
  412.  
  413.     /* invoke the method */
  414.     if (null(method = cdr(msg)))
  415.         xlerror("bad method",method);
  416.     switch (ntype(method)) {
  417.     case SUBR:
  418.         val = (*getsubr(method))();
  419.         break;
  420.     case CLOSURE:
  421.         if (gettype(method) != s_lambda)
  422.             xlerror("bad method",method);
  423.         val = evmethod(obj,msgcls,method);
  424.         break;
  425.     default:
  426.         xlerror("bad method",method);
  427.     }
  428.  
  429.     /* after creating an object, send it the ":isnew" message */
  430.     if (car(msg) == k_new && !null(val)) {
  431.         xlprot1(val);
  432.         sendmsg(val,getclass(val),k_isnew);
  433.         xlpop();
  434.     }
  435.     
  436.     /* return the result value */
  437.     return (val);
  438. }
  439.  
  440. /* evmethod - evaluate a method */
  441. LOCAL LVAL NEAR evmethod(obj,msgcls,method)
  442.   LVAL obj,msgcls,method;
  443. {
  444.     LVAL oldenv,oldfenv,cptr,name,val;
  445.     LVAL olddenv=xldenv;
  446.     CONTEXT cntxt;
  447.  
  448.     /* protect some pointers */
  449.     xlstkcheck(3);
  450.     xlsave(oldenv);
  451.     xlsave(oldfenv);
  452.     xlsave(cptr);
  453.  
  454.     /* create an 'object' stack entry and a new environment frame */
  455.     oldenv = xlenv;
  456.     oldfenv = xlfenv;
  457.     xlenv = cons(cons(obj,msgcls),getenvi(method));
  458.     xlenv = xlframe(xlenv);
  459.     xlfenv = getfenv(method);
  460.  
  461.     /* bind the formal parameters */
  462.     xlabind(method,xlargc,xlargv);
  463.  
  464.     /* setup the implicit block */
  465.     if (!null(name = getname(method)))
  466.         xlbegin(&cntxt,CF_RETURN,name);
  467.  
  468.     /* execute the block */
  469.     if (name && setjmp(cntxt.c_jmpbuf))
  470.         val = xlvalue;
  471.     else
  472.         for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
  473.             val = xleval(car(cptr));
  474.  
  475.     /* finish the block context */
  476.     if (!null(name))
  477.         xlend(&cntxt);
  478.  
  479.     /* restore the environment */
  480.     xlenv = oldenv;
  481.     xlfenv = oldfenv;
  482.     xlunbind(olddenv);
  483.  
  484.     /* restore the stack */
  485.     xlpopn(3);
  486.  
  487.     /* return the result value */
  488.     return (val);
  489. }
  490.  
  491. /* getivcnt - get the number of instance variables for a class */
  492. #ifdef ANSI
  493. LOCAL int NEAR getivcnt(LVAL cls, int ivar)
  494. #else
  495. LOCAL int getivcnt(cls,ivar)
  496.   LVAL cls; int ivar;
  497. #endif
  498. {
  499.     LVAL cnt;
  500.     if (null(cnt = getivar(cls,ivar)) || !fixp(cnt))
  501.         xlfail("bad value for instance variable count");
  502.     return ((int)getfixnum(cnt));
  503. }
  504.  
  505. /* listlength - find the length of a list */
  506. #ifdef ANSI
  507. LOCAL int NEAR listlength(LVAL list)
  508. #else
  509. LOCAL int listlength(list)
  510.   LVAL list;
  511. #endif
  512. {
  513.     int len;
  514.     for (len = 0; consp(list); len++)
  515.         list = cdr(list);
  516.     return (len);
  517. }
  518.  
  519. /* obsymbols - initialize symbols */
  520. VOID obsymbols()
  521. {
  522.     /* enter the object related symbols */
  523.     s_self  = xlenter("SELF");
  524.     k_new   = xlenter(":NEW");
  525.     k_isnew = xlenter(":ISNEW");
  526.     k_prin1 = xlenter(":PRIN1");
  527.  
  528.     /* get the Object and Class symbol values */
  529.     cls_object = getvalue(xlenter("OBJECT"));
  530.     cls_class  = getvalue(xlenter("CLASS" ));
  531.     /* $putpatch.c$: "MODULE_XLOBJ_C_OBSYMBOLS" */
  532. }
  533.  
  534. /* xloinit - object function initialization routine */
  535. VOID xloinit()
  536. {
  537.     /* create the 'Class' object */
  538.     cls_class = xlclass("CLASS",CLASSSIZE);
  539.     setelement(cls_class,0,cls_class);
  540.  
  541.     /* create the 'Object' object */
  542.     cls_object = xlclass("OBJECT",0);
  543.  
  544.     /* finish initializing 'class' */
  545.     setivar(cls_class,SUPERCLASS,cls_object);
  546.  
  547.     xladdivar(cls_class,"PNAME");           /* ivar number 7  TAA Mod */
  548.     xladdivar(cls_class,"IVARTOTAL");       /* ivar number 6 */
  549.     xladdivar(cls_class,"IVARCNT");         /* ivar number 5 */
  550.     xladdivar(cls_class,"SUPERCLASS");      /* ivar number 4 */
  551.     xladdivar(cls_class,"CVALS");           /* ivar number 3 */
  552.     xladdivar(cls_class,"CVARS");           /* ivar number 2 */
  553.     xladdivar(cls_class,"IVARS");           /* ivar number 1 */
  554.     xladdivar(cls_class,"MESSAGES");        /* ivar number 0 */
  555.     xladdmsg(cls_class,":NEW",FT_CLNEW);
  556.     xladdmsg(cls_class,":ISNEW",FT_CLISNEW);
  557.     xladdmsg(cls_class,":ANSWER",FT_CLANSWER);
  558.  
  559.     /* finish initializing 'object' */
  560.     setivar( cls_object,SUPERCLASS,NIL);
  561.     xladdmsg(cls_object,":ISNEW",FT_OBISNEW);
  562.     xladdmsg(cls_object,":CLASS",FT_OBCLASS);
  563.     xladdmsg(cls_object,":SHOW",FT_OBSHOW);
  564.     xladdmsg(cls_object,":PRIN1",FT_OBPRIN1);
  565.     /* $putpatch.c$: "MODULE_XLOBJ_C_XLOINIT" */
  566.  
  567. }
  568.  
  569.  
  570. /* default :PRIN1 method for objects */
  571. LVAL obprin1()
  572. {
  573.     LVAL self,fptr;
  574.  
  575.     /* get self and the file pointer */
  576.     self = xlgaobject();
  577.     fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
  578.     xllastarg();
  579.  
  580.     /* print it */
  581.     xputobj(fptr,self);
  582.  
  583.     /* return the object */
  584.     return (self);
  585. }
  586.  
  587. /* called by xlprint to tell an object to print itself by faking
  588.    a call like (send obj :prin1 fptr) */
  589. VOID putobj(fptr,obj)
  590.     LVAL fptr,obj;
  591. {
  592.     FRAMEP oldargv;
  593.     int oldargc;
  594.  
  595.     /* check if there's room for the new call frame (5 slots needed) */
  596.     if (xlsp >= (xlargstktop-5)) xlargstkoverflow();
  597.  
  598.     /* create a new (dummy) call frame. dummy because (1) stack backtraces
  599.      * won't work anyway since if there's an error when PRINTing an object,
  600.      * that error will probably occur again during the backtrace, and
  601.      * (2) sendmsg() trashes the message selector slot.
  602.      */
  603.     *xlsp   = cvfixnum((FIXTYPE)(xlsp - xlfp));
  604.     xlfp    = xlsp++;   /* new frame pointer */
  605.     *xlsp++ = NIL;      /* dummy function */
  606.     *xlsp++ = cvfixnum((FIXTYPE) 2);    /* we have two arguments */
  607.     *xlsp++ = k_prin1; /* 1st arg: the message (trashed by sendmsg()) */
  608.     *xlsp++ = fptr;     /* 2nd arg: the file/stream */
  609.  
  610.     /* save old xlargc and xlargv. set up new ones */
  611.     oldargc = xlargc;
  612.     oldargv = xlargv;
  613.     xlargc  = 1;        /* one arg to be picked up */
  614.     xlargv  = xlfp + 4; /* points at 2nd arg: the file/stream */
  615.  
  616.     /* do it */
  617.     sendmsg(obj,getclass(obj),k_prin1);
  618.  
  619.     /* restore xlargc and xlargv */
  620.     xlargc  = oldargc;
  621.     xlargv  = oldargv;
  622.  
  623.     /* remove call frame */
  624.     xlsp    = xlfp;
  625.     xlfp   -= (int)getfixnum(*xlfp);
  626. }
  627.  
  628.  
  629.